unit PascalFormalGrammars;

interface

uses
  FormalGrammars,
  SysUtils,
  JvUtils;

const
  LABEL_PASCAL_IDENTIFIER = 3;
  LABEL_FREE_SPACE = 4;
  LABEL_COMMENT_1 = 5;
  LABEL_COMMENT_2 = 6;
  LABEL_COMMENT_3 = 7;
  LABEL_COMMA = 8;
  LABEL_SEMICOLON = 9;
  LABEL_COLON = 10;
  LABEL_DOT = 11;
  LABEL_EQUAL = 12;
  LABEL_ASSIGN  = 13;
  LABEL_INTERFACE_SECTION = 14;
  LABEL_USES_SECTION =  15;
  LABEL_IMPLEMENTATION_SECTION = 16;
  LABEL_PAS_UNIT = 17;
  LABEL_OPENED_ARC = 18;
  LABEL_CLOSED_ARC = 19;
  LABEL_ROUTINE_HEADER = 20;
  LABEL_ACCESS_MODIFIER = 21;
  LABEL_CLASS_DEFINITION = 22;
  LABEL_TYPE_ALIAS_DEFINITION = 23;
  LABEL_ENUM_DEFINITION = 24;
  LABEL_TYPE_SECTION = 25;
  LABEL_CODE_BLOCK = 26;
  LABEL_BEGIN = 27;
  LABEL_END = 28;
  LABEL_SYMBOL_ASSIGNMENT = 29;
  LABEL_SYMBOL_ACCESS = 30;

procedure InitializeStandardGrammarElements;

{$IFDEF LEXEME_DEBUG}
procedure UnitTest;
{$ENDIF}

var
  ID: ILexeme;

  Comment1: ILexeme;
  Comment2: ILexeme;
  Comment3: ILexeme;

  _Var, _Const, _Out, _End, _Begin: ILexeme;

  FreeSpace: ILexeme;
  MaybeFree: ILexeme;

  Comma: ILexeme;
  SemiColon: ILexeme;
  Dot: ILexeme;
  Colon: ILexeme;
  Equal: ILexeme;
  Assign: ILexeme;
  OpenedArc, ClosedArc: ILexeme;
  BinaryOperator: ILexeme;

  UnitHeader: ILexeme;
  IDList: ILexeme;

  VarSingleTypeDeclaration: ILexeme;
  ConstSingleDeclaration: ILexeme;

  _Type: ILexeme;

  SymbolAssignment: ILexeme;
  SymbolAccess: ILexeme;
  Expression: ILexeme;
  ExpressionList: ILexeme;

  VarSection: ILexeme;
  ConstSection: ILexeme;
  UsesSection: ILexeme;

  ParameterListSingleType: ILexeme;
  ParameterList: ILexeme;
  RoutineHeader: ILexeme;

  AccessModifier: ILexeme;
  ClassDefinition: ILexeme;
  TypeAliasDefinition: ILexeme;
  EnumDefinition: ILexeme;

  CodeBlock: ILexeme;
  TypeSection: ILexeme;
  Routine: ILexeme;
  InterfaceSection: ILexeme;
  ImplementationSection: ILexeme;
  
  PasUnit: ILexeme;

implementation

uses
{$IFDEF LEXEME_DEBUG}
  Forms,
{$ENDIF}
  PasFileParser;

const
  AllChars: TSysCharSet = [Char(0)..Char(255)];

{$IFDEF LEXEME_DEBUG}
procedure Conform(const l: ILexeme; const s: string); forward;
{$ENDIF}

procedure InitializeStandardGrammarElements;

  function GOperator(const opSymbol: string; const aLabel: TLabel = L_NONE): ILexeme;
  begin
    Result := GSequence([
      MaybeFree,
      GText(opSymbol),
      MaybeFree
    ], aLabel);
  end;

var
  lTemp: ILexeme;

begin
  if not Assigned(ID) then
  begin
    ID := GSymbols(['A'..'Z', 'a'..'z', '0'..'9', '_'], LABEL_PASCAL_IDENTIFIER);

    Comment1 := GSequence([
      GText('{'),
      GSymbols(AllChars - ['}']),
      GText('}')
    ], LABEL_COMMENT_1);

    Comment2 := GSequence([
      GText('//'),
      GSymbols(AllChars - [#10, #13]),
      GMaybe(GSymbols([#10, #13]))
    ], LABEL_COMMENT_2);

    _Var := GText('var');
    _Const := GText('const');
    _Out := GText('out');
    _Begin := GText('begin', LABEL_BEGIN);
    _End := GText('end', LABEL_END);

    FreeSpace := GRepeats(
      GSequence([
        GMaybe(GSymbols([' ', #10, #13, #9])),
        GMaybe(Comment1),
        GMaybe(Comment2)
      ]), LABEL_FREE_SPACE, 1
    );
    MaybeFree := GMaybe(FreeSpace);
    Comma := GOperator(',', LABEL_COMMA);
    SemiColon := GOperator(';', LABEL_SEMICOLON);
    Colon := GOperator(':', LABEL_COLON);
    Dot := GOperator('.', LABEL_DOT);
    Equal := GOperator('=', LABEL_EQUAL);
    Assign := GOperator(':=', LABEL_ASSIGN);
    OpenedArc := GOperator('(', LABEL_OPENED_ARC);
    ClosedArc := GOperator(')', LABEL_CLOSED_ARC);

    BinaryOperator := GSelect([
      GOperator('+'),
      GOperator('-'),
      GOperator('*'),
      GOperator('/'),
      GOperator('div'),
      GOperator('mod'),
      GOperator('=')
    ]);


    
    UnitHeader := GSequence([
      GText('unit'),
      FreeSpace,
      ID,
      SemiColon
   ]);

    IDList := GSequence([
      GRepeats(
        GSequence([
          ID,
          Comma
        ])
      ),
      ID
    ]);

    ConstSingleDeclaration := GSequence([
      ID,
      Equal,
      ID, // TODO: It's not completely correct!!! Should be expression
      SemiColon
    ]); // TODO: What about typed constants???

    _Type := GSelect([
      GSequence([
        GText('set of '),
        ID
      ]),
      GSequence([
        GText('array of '),
        GFar(@_Type)
      ]),
      ID
    ]);

    SymbolAssignment := GSequence([
      ID,
      Assign,
      GFar(@Expression)
    ], LABEL_SYMBOL_ASSIGNMENT);

    SymbolAccess := GSelect([
      GSequence([ // object's value access, or method call
        ID,
        Dot,
        GFar(@SymbolAccess)
      ]),
      GSequence([  // function call
        ID,
        MaybeFree,
        OpenedArc,
        GMaybe(
          GFar(@ExpressionList)   // maybe with parameters
        ),
        ClosedArc
      ]),
      ID  // symbol access
    ], LABEL_SYMBOL_ACCESS);

    Expression := GSelect([
      GSequence([
        SymbolAccess,
        BinaryOperator,
        GFar(@Expression)
      ]),
      GSequence([
        OpenedArc,
        GFar(@Expression),
        ClosedArc
      ]),
      SymbolAccess
    ]);
    ExpressionList := GSequence([
      GRepeats(
        GSequence([
          Expression,
          Comma
        ])
      ),
      Expression
    ]);

    VarSingleTypeDeclaration := GSequence([
      IDList,
      Colon,
      _Type,
      SemiColon
    ]);    

    VarSection := GSequence([
      _Var,
      FreeSpace,
      GRepeats(VarSingleTypeDeclaration, L_NONE, 1)
    ]);

    ConstSection := GSequence([
      _Const,
      FreeSpace,
      GRepeats(ConstSingleDeclaration, L_NONE, 1)
    ]);

    UsesSection := GSequence([
      GText('uses'),
      FreeSpace,
      IDList,
      SemiColon
    ], LABEL_USES_SECTION);

    ParameterListSingleType := GSequence([
      GMaybe(
        GSequence([
          GSelect([
            _Var,
            _Const,
            _Out
          ]),
          FreeSpace
      ])),
      IDList,
      MaybeFree,
      Colon,
      MaybeFree,
      _Type
    ]);
    ParameterList := GSequence([
      GRepeats(GSequence([
        ParameterListSingleType,
        SemiColon
      ])),
      ParameterListSingleType
    ]);

    RoutineHeader := GSequence([
      GSelect([
        GText('procedure'),
        GText('function')
      ]),
      FreeSpace,
      ID,
      GMaybe(GSequence([
        OpenedArc,
        GMaybe(ParameterList),
        ClosedArc
        ])),
      GMaybe(GSequence([
        Colon,
        _Type
      ])),
      SemiColon
    ], LABEL_ROUTINE_HEADER);

    AccessModifier := GSelect([
       GText('private'),
       GText('protected'),
       GText('public'),
       GText('published')
    ], LABEL_ACCESS_MODIFIER);
    
    ClassDefinition := GSequence([
      ID,
      Equal,
      GText('class'),
      MaybeFree,
      GMaybe(GSequence([
        OpenedArc,
        IDList,
        ClosedArc
      ])),
      GRepeats(GSequence([
        GMaybe(
          GSequence([
            AccessModifier,
            FreeSpace
          ])
        ),
        RoutineHeader
      ])),
      _End,
      SemiColon
    ], LABEL_CLASS_DEFINITION);

    TypeAliasDefinition := GSequence([
      ID,
      Equal,
      _Type,
      SemiColon
    ], LABEL_TYPE_ALIAS_DEFINITION);

    EnumDefinition := GSequence([
      ID,
      Equal,
      OpenedArc,
      IDList,
      ClosedArc,
      SemiColon
    ], LABEL_ENUM_DEFINITION);

    lTemp := GSelect([
      SymbolAssignment,
      SymbolAccess       // procedure or function call
    ]);
    lTemp := GSelect([
      GSequence([
        GRepeat([
          lTemp,
          GRepeats(SemiColon, L_NONE, 1)
        ]),
        GMaybe(
          GSequence([
            lTemp,
            GRepeats(SemiColon)
          ])
        )
      ]),
      lTemp
    ]);
    CodeBlock := GSelect([
      GSequence([
        _Begin,
        FreeSpace,
        GMaybe(
          GFar(@CodeBlock)
        ),
        MaybeFree,
        _End
      ]),
      lTemp
    ], LABEL_CODE_BLOCK);

    TypeSection := GSequence([
      GText('type'),
      FreeSpace,
      GRepeats(GSelect([
        ClassDefinition,
        TypeAliasDefinition,
        EnumDefinition
      ]), L_NONE, 1)
    ], LABEL_TYPE_SECTION);



    Routine := GSequence([
      RoutineHeader,
      GRepeats(
        GSelect([
          VarSection,
          ConstSection
      ])),
      MaybeFree,
      _Begin,
      FreeSpace,
      GMaybe(
        CodeBlock
      ),
      MaybeFree,
      _End,
      SemiColon
    ]);

    InterfaceSection := GSequence([
      GText('interface'),
      FreeSpace,
      GMaybe(UsesSection),
      GRepeats(
        GSelect([
          TypeSection,
          VarSection,
          ConstSection
        ]))
    ], LABEL_INTERFACE_SECTION);

    ImplementationSection := GSequence([
      GText('implementation'),
      FreeSpace,
      GMaybe(UsesSection),
      GRepeats(
        GSelect([
          TypeSection,
          VarSection,
          ConstSection
        ]))
    ], LABEL_IMPLEMENTATION_SECTION);

    PasUnit := GSequence([
      MaybeFree,
      UnitHeader,
      InterfaceSection,
      ImplementationSection,
      _End,
      MaybeFree,
      Dot
    ], LABEL_PAS_UNIT);
  end;
end;

{$IFDEF LEXEME_DEBUG}
procedure Conform(const l: ILexeme; const s: string);
var
  e: IMatchError;
  r: IMatchSuccess;
begin
  if not Grammar(l).Apply(s, e, r) then
  begin
    raise Exception.Create(e.GetErrorMessage + ':' + IntToStr(e.GetPosition) + ' by ' + IntToStr(e.GetLabel) + sLineBreak + 'Cannot understand: "' + GetWordOnPos(s, e.GetPosition));
  end;
end;

procedure NotConform(const l:ILexeme; const s: string);
var
  e : IMatchError;
  r: IMatchSuccess;
begin
  if Grammar(l).Apply(s, e, r) then
    raise Exception.Create('Must not conform');
end;

procedure UnitTest;
begin
  Conform(Comment1, '{asdfasd{ asfa  asdf # 234134 asdf '#10'}');
  NotConform(Comment1, '{asdfasd{a } }');

  Conform(Comment2, '// asdf asdf aweroaijfasefdrie');
  Conform(Comment2, '// asdf asdf aweroaijfasefdrie'#10#13);
  NotConform(Comment2, 'a// asdf asdf aweroaijfasefdrie');
  Conform(FreeSpace, '{asdfasd{ asfa  asdf # 234134 asdf '#10'}');
  Conform(UnitHeader, 'unit{sadfa}Pasu{sadf};');
  Conform(IDList, 'a, b, c124, _34');
  Conform(_Type, 'TObject');
  Conform(_Type, 'set of Integer');
  Conform(_Type, 'array of TWideChar');
  Conform(_Type, 'array of array of set of TIntBucketList');
  Conform(VarSection, 'var te : array of TObject;');
  Conform(VarSection, 'var a, b : Integer; v: Real;   te : array of array of IInterface; ');
  Conform(UsesSection, 'uses           sadfasdfasdf  '#10#13' , safd '#10#13' ;');
  Conform(UsesSection, 'uses{sdf}sadfasdfasdf  '#10#13' , safd '#10#13';// abra casafasd adf');
  Conform(ConstSection, 'const a = 1; b= 3; '#10#13' c =545;');
  Conform(ImplementationSection, 'implementation ');
  Conform(RoutineHeader, 'procedure Test_p(const a, b: Integer; var l: array of TObject; out ar: Result);');
  Conform(RoutineHeader, 'procedure OtherProc;');
  Conform(RoutineHeader, 'procedure OtherProc2();');
  Conform(RoutineHeader, 'function a: Integer;');
  Conform(RoutineHeader, 'procedure b(const a: Integer): HResult;');

  Conform(ClassDefinition, 'TMyClass = class end;');
  Conform(ClassDefinition, 'TMyClass = class(TInterfacedObject, IUnknown) ' +
    'private ' +
    'procedure DoSomething(); '+
    'procedure DoSomething2(); '+
    ' published ' +
    'procedure DoSomethingElse(const a: Integer); ' +
    'function test(const a: Integer; var test1: array of string; out b: set of TWideChar);' +
    'end;'
  );

  Conform(SymbolAssignment, 'a := 5');
  Conform(SymbolAssignment, 'a := 5 + 4 * (Pow(X) + 1)');
  NotConform(SymbolAssignment, 'a := 5;');

  Conform(SymbolAccess, '4');
  Conform(SymbolAccess, 'GetTickCount');
  Conform(SymbolAccess, 'GetTickCount()');
  Conform(SymbolAccess, 'IntToStr(5)');
  Conform(SymbolAccess, 'obj1.prop1.Method2(4 - X)');
  Conform(SymbolAccess, 'Inc(a, Pow(2, i))');

  Conform(Expression, '4');
  Conform(Expression, '5 + 4');
  Conform(Expression, '(5)');
  Conform(Expression, '5 + 4 * ( N + X * i)');
  Conform(Expression, 'GetValue(3) + 3');
  Conform(Expression, 'obj1.prop1.Method2(5 + 4 * ( N + X * i)) - obj.GetConstant() + obj2.Value');

  Conform(CodeBlock, 'a := 1');
  Conform(CodeBlock, 'a := 1; ;;; ; obj1.CallMethod(); a := a + obj1.Prop1; ; Inc(a, Pow(2, i)); ; ; ;');
//  Conform(CodeBlock, 'begin   end');
  Conform(CodeBlock, 'begin Inc(5)  end');

//  Conform(Routine, 'procedure Test(); var a, b: Integer; const x = 1; var c: set of int; c: set of WideString; begin a := 1; end;');

  Conform(TypeSection, 'type TMyClass = class(TInterfacedObject, IUnknown) end; TMyClass = class(TObject) function a: Integer; end;');
  Conform(InterfaceSection, 'interface uses Windows, SysInit;  type TMyClass = class(TObject) published function Test(out R2: array of Boolean): set of Integer; end;  TIntArray = array of Integer; var a: TIntArray; const v = 5;');

  Conform(PasUnit, '  unit   PasUnite;   interface uses Windows, Messages; const WM_PAINT = 15;          implementation end .');
end;
{$ENDIF}

{$IFDEF LEXEME_DEBUG}
initialization
  RegisterLabel(LABEL_PASCAL_IDENTIFIER, 'ID');
  RegisterLabel(LABEL_FREE_SPACE, 'Free Space');
  RegisterLabel(LABEL_COMMENT_1, '{Comment}');
  RegisterLabel(LABEL_COMMENT_2, '//Comment');
  RegisterLabel(LABEL_COMMENT_3, '(*Comment*)');
  RegisterLabel(LABEL_COMMA, 'Comma,');
  RegisterLabel(LABEL_SEMICOLON, 'Semicolon;');
  RegisterLabel(LABEL_COLON, 'Colon:');
  RegisterLabel(LABEL_DOT, 'Dot.');
  RegisterLabel(LABEL_EQUAL, 'Equla=');
  RegisterLabel(LABEL_ASSIGN, 'Assign:=');
  RegisterLabel(LABEL_INTERFACE_SECTION, 'Interface section');
  RegisterLabel(LABEL_USES_SECTION, 'Uses section');
  RegisterLabel(LABEL_IMPLEMENTATION_SECTION, 'Implementation section');
  RegisterLabel(LABEL_PAS_UNIT, 'Pascal Unit');
  RegisterLabel(LABEL_OPENED_ARC, 'Opened Arc (');
  RegisterLabel(LABEL_CLOSED_ARC, 'Closed Arc )');
  RegisterLabel(LABEL_ROUTINE_HEADER, 'Routine header');
  RegisterLabel(LABEL_ACCESS_MODIFIER, 'Access modifier');
  RegisterLabel(LABEL_CLASS_DEFINITION, 'Class definition');
  RegisterLabel(LABEL_TYPE_ALIAS_DEFINITION, 'Type alias definition');
  RegisterLabel(LABEL_ENUM_DEFINITION, 'Enum definition');
  RegisterLabel(LABEL_TYPE_SECTION, 'Type section');
  RegisterLabel(LABEL_CODE_BLOCK, 'Code block');
  RegisterLabel(LABEL_BEGIN, 'begin');
  RegisterLabel(LABEL_END, 'end');
  RegisterLabel(LABEL_SYMBOL_ASSIGNMENT, 'Symbol assignment');
  RegisterLabel(LABEL_SYMBOL_ACCESS, 'Symbol access');
{$ENDIF}

end.
